home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / retrieve.t < prev    next >
Text File  |  1988-05-02  |  11KB  |  291 lines
  1. (herald retrieve
  2.   (env tsys (osys dump_codes)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Retrieving dumped objects.
  28. ;;;   See dump_codes.t, dump.t as well.
  29.  
  30. ;;; This is a vector containing a procedure to decode each possible type byte.
  31. ;;; Initially it is filled with an error routine.
  32.  
  33. (block
  34.   (define *decode-dispatch-vec* (make-vector 256))
  35.  
  36.   (vector-fill *decode-dispatch-vec*
  37.                (lambda (code in)
  38.                  (ignore in)
  39.                  (error "retrieve got an unknown type code ~S" code)))
  40.   t)
  41.  
  42. ;;; Puts the proper procedure into the dispatch vector.  There are four
  43. ;;; decoding procedures.
  44.  
  45. (define (add-dispatch code shared? data?)
  46.   (receive (proc count)
  47.            (cond ((and shared? data?)
  48.                   (return decode-shared&data 8))
  49.                  (data?
  50.                   (return decode-data 4))
  51.                  (shared?
  52.                   (return decode-shared 2))
  53.                  (else
  54.                   (return decode-plain 1)))
  55.     (do ((i code (fx+ 1 i)))
  56.         ((fx>= i (fx+ code count)))
  57.       (set (vref *decode-dispatch-vec* i) proc))))
  58.  
  59. ;;; These are the four type-byte decoders.  They just extract the
  60. ;;; proper fields and return them along with the normalized type
  61. ;;; code.
  62.  
  63. (define (decode-plain code in)
  64.   (ignore in)
  65.   (return code nil nil))
  66.  
  67. (define (decode-shared code in)
  68.   (ignore in)
  69.   (return (fixnum-logand code #xFE) (fixnum-odd? code) nil))
  70.  
  71. (define (decode-data code in)
  72.   (let ((data (fixnum-logand code #x3)))
  73.     (return (fixnum-logand code #xFC) nil (get-bytes in (fx+ 1 data)))))
  74.  
  75. (define (decode-shared&data code in)
  76.   (let ((data (fixnum-ashr (fixnum-logand code #x6) 1)))
  77.     (return (fixnum-logand code #xF8)
  78.             (fixnum-odd? code)
  79.             (get-bytes in (fx+ 1 data)))))
  80.  
  81. ;;; All of the handled types.
  82. ;;;             TYPE             SHARED?    SIZE FIELD?
  83. (add-dispatch dump/null            nil         nil)
  84. (add-dispatch dump/char            nil         nil)
  85. (add-dispatch dump/true            nil         nil)
  86. (add-dispatch dump/pair            t           nil)
  87. (add-dispatch dump/coded           t           nil)
  88. (add-dispatch dump/object-ref      nil         t)
  89. (add-dispatch dump/positive-fixnum nil         t)
  90. (add-dispatch dump/negative-fixnum nil         t)
  91. (add-dispatch dump/string          t           t)
  92. (add-dispatch dump/symbol          t           t)
  93. (add-dispatch dump/vector          t           t)
  94. (add-dispatch dump/byte-vector     t           t)
  95. (add-dispatch dump/positive-bignum t           t)
  96. (add-dispatch dump/negative-bignum t           t)
  97. (add-dispatch dump/double-flonum   t           t)
  98.  
  99. ;;; Opens a dumped file, reads in the counts of shared objects,
  100. ;;; makes vectors to hold the shared objects, and returns an object
  101. ;;; for the port.
  102.  
  103. (define-predicate retrieve-port?)
  104. (define-operation (retrieve-port-magic-number self) 0)
  105. (define-operation (set-decoder self decoder))
  106.  
  107. (define retrieve-magic-number -1)
  108.  
  109. (define (default-retrieve-decoder x) ;++ Code Gen bug
  110.   (ignore x)
  111.   (return nil nil))
  112.  
  113. (define (maybe-open-retrieve-file filename)
  114.   (let ((in (maybe-open filename 'in)))
  115.     (if (not in)
  116.         '#f
  117.         (let ((magic (get-bytes in 4)))
  118.           (cond ((fx= magic retrieve-magic-number)
  119.                  (let ((port (make-retrieve in)))
  120.                    (set-decoder port default-retrieve-decoder) ;++ fix this
  121.                    port))
  122. ;++ flush
  123. ;                (else
  124. ;                 (format t "~&** Warning: obsolete dump file ~A~%"
  125. ;                         (filename->string filename))
  126. ;                 (close in)
  127. ;                 (let ((in (maybe-open filename 'in)))
  128. ;                   (make-old-retrieve in))))))))
  129.                 (else
  130.                  (error "bad magic dump number in ~S" filename)))))))
  131.  
  132. (define (make-retrieve in)
  133.   (let* ((duplicate-count -1)
  134.          (status (locative duplicate-count)))
  135.     (receive (done? size)
  136.              (check-port-status in (get-bytes in 4))
  137.       (let ((objects (make-vector size))
  138.             (decoder nil))  ;++ fix this richard
  139.         (object nil
  140.           ((read self)
  141.            (if done?
  142.                (end-of-file self)
  143.                (receive (end? obj)
  144.                         (check-port-status
  145.                          in
  146.                          (retrieve-object in status objects decoder))
  147.                  (if end? (set done? t))
  148.                  obj)))
  149.           ((close self)
  150.            (close in))
  151.           ((set-decoder self d)
  152.            (set decoder d))
  153.           ((retrieve-port-magic-number self) retrieve-magic-number)
  154.           ((retrieve-port? self) '#t)
  155.           ((print-type-string self) "Retrieve-port"))))))
  156.  
  157. (define (check-port-status in obj)
  158.   (let ((byte (readc in)))
  159.     (cond ((eof? byte)
  160.            (return t (error "corrupt dump file - unexpected EOF")))
  161.           ((fx= dump/begin-object (char->ascii byte))
  162.            (return nil obj))
  163.           ((fxn= dump/end-of-file (char->ascii byte))
  164.            (return t (error "corrupt dump file - missing BEGIN-OBJECT")))
  165.           ((not (eof? (readc in)))
  166.            (return t (error "corrupt dump file - END-OF-FILE inside file")))
  167.           (else
  168.            (return t obj)))))
  169.  
  170. ;;; Read in and decode the next type byte.  Checks for end-of-file.
  171.  
  172. (define (get-next-code in)
  173.   (let ((char (readc in)))
  174.     (if (eof? char)
  175.         (error "corrupt dump file - unexpected EOF")
  176.         ((vref *decode-dispatch-vec* (char->ascii char))
  177.            (char->ascii char)
  178.            in))))
  179.  
  180. ;;; Retrieves the next object.  This routine does EOF checking and
  181. ;;; adds shared objects to the vectors.  Pairs and vectors must
  182. ;;; be checked for sharing before their fields are retrieved so
  183. ;;; that circular ones will be reconstructed properly.
  184.  
  185. (define (retrieve-object in status objects decoder)
  186.   (iterate next ()
  187.     (receive (code shared? data)
  188.              (get-next-code in)
  189.       (let ((index (if shared? 
  190.                        (modify (contents status)
  191.                                (lambda (x) (fx+ x 1)))
  192.                        nil)))
  193.         (receive (thing accessors)
  194.                  (select code
  195.                    ((dump/object-ref) (return (vref objects data) nil))
  196.                    ((dump/coded) (let* ((key (next))
  197.                                         (data (next))
  198.                                         (count (next)))
  199.                                    (receive (maker accessors)
  200.                                             (decoder key)
  201.                                      (cond ((not maker)
  202.                                             (error '"no maker for key ~S" key))
  203.                                            ((fxn= count (length accessors))
  204.                                             (error
  205.                                '"wrong number of accessors for key ~S" key))
  206.                                            (else
  207.                                             (return (apply maker data)
  208.                                                     accessors))))))
  209.                    (else
  210.                     (return (get-next-object in code data) nil)))
  211.           (if shared? (set (vref objects index) thing))
  212.           (select code
  213.             ((dump/pair)
  214.              (set (car thing) (next))
  215.              (set (cdr thing) (next)))
  216.             ((dump/vector)
  217.              (do ((i 0 (fx+ 1 i)))
  218.                  ((fx>= i data))
  219.                (set (vref thing i) (next))))
  220.             ((dump/coded)
  221.              (walk (lambda (acc)
  222.                      (set (acc thing) (next)))
  223.                    accessors)))
  224.           thing)))))
  225.  
  226. ;;; Actually retrieves the next object.  Dispatches on the type code.
  227.  
  228. (define (get-next-object in code data)
  229.   (select code
  230.     ((dump/null)            nil)
  231.     ((dump/true)            '#t)
  232.     ((dump/char)            (readc in))
  233.     ((dump/positive-fixnum) data)
  234.     ((dump/negative-fixnum) (fx- 0 data))
  235.     ((dump/pair)            (cons nil nil))
  236.     ((dump/vector)          (make-vector data))
  237.     ((dump/string)          (get-string in data))
  238.     ((dump/symbol)          (string->symbol (get-string in data)))
  239.     ((dump/double-flonum)   (get-double-float in data))
  240.     ((dump/byte-vector)     (get-bytev in data))
  241.     ((dump/positive-bignum) (get-bignum in data))
  242.     ((dump/negative-bignum) (- (get-bignum in data)))
  243.     (else
  244.      (error "retrieve got an unknown type code ~S" code))))
  245.  
  246. ;;; Routines to reconstruct the various types.
  247.  
  248. (define (get-string in size)
  249.   (let ((string (make-string size)))
  250.     (read-block in (string-text string) size)
  251.     string))
  252.  
  253. (define (get-double-float in size)
  254.   (let* ((sign (if (eq? (get-byte in) 1) 1 -1))
  255.          (e (get-bytes in 4))
  256.          (m (if (fx= size 0)
  257.                 (get-bytes in 4)
  258.                 (get-bignum in size))))
  259.     (integer-encode-float sign m e)))
  260.  
  261. (define (get-bytev in size)
  262.   (let ((bytev (make-bytev size)))
  263.     (read-block in bytev size)
  264.     bytev))
  265.  
  266. (define (get-bignum in size)
  267.   (let ((num (create-bignum size)))
  268.     (set-bignum-sign! num 1)
  269.     (do ((i 0 (fx+ 1 i)))
  270.         ((fx>= i size))
  271.       (set (bignum-digit num i) (get-bytes in 4)))
  272.     num))
  273.  
  274. ;;; Read in various numbers of bytes.
  275.  
  276. (define (get-byte in)
  277.   (char->ascii (readc in)))
  278.  
  279. (define (get-two-bytes in)
  280.   (let ((value (get-byte in)))
  281.     (fixnum-logior (fixnum-ashl (get-byte in) 8)
  282.                    value)))
  283.  
  284. (define (get-bytes in count)
  285.   (let ((end (fixnum-ashl count 3)))
  286.     (do ((i 0 (fx+ 8 i))
  287.          (val 0 (fixnum-logior (fixnum-ashl (get-byte in) i)
  288.                                val)))
  289.         ((fx>= i end)
  290.          val))))
  291.